SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00009 1 05-25-9408:01ALL BJÖRN FELTEN Going International SWAG9405 39 èo unit CaseUtil;ππinterfaceππtypeπ DelimType =π recordπ thousands,π decimal,π date,π time : array[0..1] of Char;π end;ππ CurrType = (leads, { symbol precedes value }π trails, { value precedes symbol }π leads_, { symbol, space, value }π _trails, { value, space, symbol }π replace); { replaced }ππ CountryType =π recordπ DateFormat : Word; { 0: USA, 1: Europe, 2: Japan }π CurrSymbol : array[0..4] of Char;π Delimiter : DelimType; { Separators }π CurrFormat : CurrType; { Way currency is formatted }π CurrDigits : Byte; { Digits in currency }π Clock24hrs : Boolean; { True if 24-hour clock }π CaseMapCall : procedure; { Lookup table for ASCII > $80 }π DataListSep : array[0..1] of Char;π CID : word;π Reserved : array[0..7] of Char;π end;ππ CountryInfo =π recordπ case InfoID: byte ofπ 1: (IDSize : word;π CountryID : word;π CodePage : word;π TheInfo : CountryType);π 2: (UpCaseTable: pointer);π end;ππvarπ CountryOk : Boolean; { Could determine country code flag }π CountryRec : CountryInfo;ππfunction Upcase(c : Char) : Char;πfunction LoCase(c : Char) : Char;πfunction UpperStr(s : string) : string;πfunction LowerStr(s : string) : string;πprocedure UpCaseStr(var s : String);πprocedure LoCaseStr(var s : String);ππimplementationππ{$R-,S-,V- }πvarπ LoTable : array[0..127] of byte;π CRP, LTP : pointer;ππ { Convert a character to upper case }π function Upcase; Assembler; asmπ mov al, cπ cmp al, 'a'π jb @2π cmp al, 'z'π ja @1π sub al, ' 'π jmp @2π@1: cmp al, 80hπ jb @2π sub al, 7ehπ push dsπ lds bx,CountryRec.UpCaseTableπ xlatπ pop dsπ@2:π end; { UpCase }ππ { Convert a character to lower case }π function LoCase; Assembler; asmπ mov al, cπ cmp al, 'A'π jb @2π cmp al, 'Z'π ja @1π or al, ' 'π jmp @2π@1: cmp al, 80hπ jb @2π sub al, 80hπ mov bx,offset LoTableπ xlatπ@2:π end; { LoCase }ππ { Convert a string to uppercase }π procedure UpCaseStr; Assembler; asmπ cldπ les di, sπ xor ax, axπ mov al, es:[di]π stosbπ xchg ax, cxπ jcxz @4π push dsπ lds bx,CountryRec.UpCaseTableπ@1: mov al, es:[di]π cmp al, 'a'π jb @3π cmp al, 'z'π ja @2π sub al, ' 'π jmp @3π@2: cmp al, 80hπ jb @3π sub al, 7ehπ xlatπ@3: stosbπ loop @1π pop dsπ@4:π end; { UpCaseStr }ππ { Convert a string to lower case }π procedure LoCaseStr; Assembler; asmπ cldπ les di, sπ xor ax, axπ mov al, es:[di]π stosbπ xchg ax, cxπ jcxz @4π@1: mov al, es:[di]π cmp al, 'A'π jb @3π cmp al, 'Z'π ja @2π or al, ' 'π jmp @3π@2: cmp al, 80hπ jb @3π sub al, 80hπ mov bx, offset LoTableπ xlatπ@3: stosbπ loop @1π@4:π end; { LoCaseStr }ππfunction UpperStr(s : string) : string;πbegin UpCaseStr(s); UpperStr:=s end;πfunction LowerStr(s : string) : string;πbegin LoCaseStr(s); LowerStr:=s end;ππbegin { init DoCase unit }π CRP := @CountryRec;π LTP := @LoTable;π asmππ { Exit if Dos version < 3.0 }π mov ah, 30hπ int 21hπ cmp al, 3π jb @1ππ { Call Dos 'Get country dependent information' function }π mov ax, 6501hπ les di, CRPπ mov bx,-1π mov dx,bxπ mov cx,41π int 21hπ jc @1ππ { Call Dos 'Get country dependent information' function }π mov ax, 6502hπ mov bx, CountryRec.CodePageπ mov dx, CountryRec.CountryIDπ mov CountryRec.TheInfo.CID, dxπ mov cx, 5π int 21hπ jc @1ππ { Build LoCase table }π les di, LTPπ mov cx, 80hπ mov ax, cxπ cldπ@3:π stosbπ inc axπ loop @3π mov di, offset LoTable - 80hπ mov cx, 80hπ mov dx, cxπ push dsπ lds bx, CountryRec.UpCaseTableπ sub bx, 7ehπ@4:π mov ax, dxπ xlatπ cmp ax, 80hπ jl @5π cmp dx, axπ je @5π xchg bx, axπ mov es:[bx+di], dlπ xchg bx, axπ@5:π inc dxπ loop @4π pop dsπ mov [CountryOk], Trueπ jmp @2π@1: mov [CountryOk], Falseπ@2:π end;πend.π 2 05-25-9408:01ALL CAMERON CLARK Credit Card check SWAG9405 27 èo π {$F+,D+,L+}ππunit Vericard;ππinterfaceππ function Vc(c : string) : char;ππimplementationππ function Vc(c : string) : char;π varπ card : string[21];π Vcard : array[0..21] of byte absolute card;π Xcard : integer;π Cstr : string[21];π y, x : integer;π beginπ x := 0;π Cstr := ' ';π Cstr := '';π fillchar(Vcard, 22, #0);π card := c;π for x := 1 to 20 doπ if (Vcard[x] in [48..57]) thenπ Cstr := Cstr + chr(Vcard[x]);π card := '';π card := Cstr;π Xcard := 0;π if NOT odd(length(card)) thenπ for x := (length(card) - 1) downto 1 doπ beginπ if odd(x) thenπ y := ((Vcard[x] - 48) * 2)π elseπ y := (Vcard[x] - 48);π if (y >= 10) thenπ y := ((y - 10) + 1);π Xcard := (Xcard + y)π endπ elseπ for x := (length(card) - 1) downto 1 doπ beginπ if odd(x) thenπ y := (Vcard[x] - 48)π elseπ y := ((Vcard[x] - 48) * 2);π if (y >= 10) thenπ y := ((y - 10) + 1);π Xcard := (Xcard + y)π end;π x := (10 - (Xcard mod 10));π if (x = 10) thenπ x := 0;π if (x = (Vcard[length(card)] - 48)) thenπ Vc := Cstr[1]π elseπ Vc := #0π end;ππEND.ππ{ .....................DRIVER EXAMple........ }ππ{$A-,B+,D-,E-,F-,I+,L-,N-,O-,R+,S+,V+}π{$M 2048,0,4096}ππprogram ValiCard;ππ { Test routine for the Mod 10 Check Digit CC validator... }ππusesπ dos,π crt,π VeriCard;ππvarπ card : string[22];π k : char;ππ procedure Squawk(Noise : byte);π beginπ case Noise ofπ 1 : beginπ Sound(400);π Delay(200);π Sound(200);π Delay(200);π Nosoundπ end;π 2 : beginπ Sound(392);π Delay(55);π Nosound;π Delay(30);π Sound(523);π Delay(55);π Nosound;π Delay(30);π Sound(659);π Delay(55);π Nosound;π Delay(30);π Sound(784);π Delay(277);π Nosound;π Delay(30);π Sound(659);π Delay(55);π Nosound;π Delay(30);π Sound(784);π Delay(1200);π Nosoundπ endπ end { case }π end;ππBEGINπ k := #0;π clrscr;π fillchar(card, 22, #0);π writeln('VC: Integer Modulo-10 Visa/Mastercard/Amex Check-Digit');π writeln(' verification routine. (c) 1990 Daniel J. Karnes');π writeln;π write(' Please enter a Credit Card number: ');π readln(card);π writeln;π writeln;π if (length(card) > 12) thenπ k := Vc(card);π if (k in ['3', '4', '5']) thenπ Squawk(2)π elseπ Squawk(1);π case k ofπ #0 : writeln(' Could NOT verify this number with any card type.')π '3' : writeln(' Card was verified as a valid Amex Card Number.');π '4' : writeln(' Card was verified as a valid VISA Card Number.');π '5' : writeln(' Card was verified as a valid Mastercard Number.')π endπEND.ππ...................πHope that helps. I've only tried it on one card number BUT it did workπfor the one and the info was received from someone in the business.π 3 05-25-9408:02ALL CHRIS LAUTENBACH Various Cool Routines SWAG9405 59 èo {π After looking around through some of my routines, I found a few that wereπ generic enough that they might be of use to the rest of ya.ππ My only request is that if you modify them and make them any cooler thanπ they already are -- send me back a copy. Oh -- yeah -- and if you useπ them in your programs give me credit, or at least a registered copy. :)ππ Here's a brief rundown of these routines:ππ proc SeqRen - renames a file, keep a certain number of backups.π EG: When you download a file, and one already exists,π it renames them. Only thing is, that this keeps themπ in age order. :)ππ func Filetype - determines the type of a file. Right now, it onlyπ knows about ZIP, ARJ, LHA, EXE and GIF files. If youπ can expand on this, feel free - and make sure youπ mail me back a copy of the new ones! :)ππ func FileExistWild - takes a wildcard filename and determines if any filesπ matching that spec are present. (Eg: *.EXE) Theπ filename doesn't even have to be a wildcard, so youπ could use this as a generic function to see if a fileπ exists or not.ππ func SizeFile - takes a filename as input, and if the file exists, itπ returns the size of the file. Returns -1 if fileπ does not exist.ππ funct SwtVal - returns the value of a command line switch. Forπ example, on a 'comms' (I hate that) program you mightπ want to be able to specify an alternate COM: port onπ the command line. With this routine you could do thatπ easily, just check for SwtVal('/COM:'). If theπ result is anything other than an empty string, thenπ that is the value. You can specify multiple wordsπ per command line parameter by replacing the spacesπ with underscores ('_').ππ func StatusBar - You've all seen those programs which display thoseπ nifty progress bars as they do things. Now you canπ do it too! Simply call this with the total number ofπ items (eg: the file size say 10 records for example)π and the current item (eg: record 4 out of 10 records)π and StatusBar will return a demi-hi-res progress barπ as a string. :)ππ func EraseFiles - Erases all the files in with a filespec matching theπ one it is passed. Example: EraseFiles('*.BAK') wouldπ delete all files with the .BAK extension in theπ current directory.π}ππprocedure SeqRen(Fn : string; Max : byte);π{ Sequentially rename file Fn, keeping Max number of files }πvar idx, rn : byte;π sfn, efn, ofn : string;π Rend, whole : boolean;π f : file;ππ function Merge(st:string; ln:longint):string;π var tmp : string;π beginπ tmp:=Long2Str(ln);π if length(tmp)>1 thenπ beginπ st[length(st)-1]:=tmp[1];π st[length(st)]:=tmp[2];π endπ elseπ st[length(st)]:=tmp[1];π Merge:=St;π end;ππbeginπ Rend:=false;whole:=false;idx:=0; { Set up variables }ππ If pos('.',fn)>0 then { Disect the filename }π beginπ sfn:=copy(fn,1,pos('.',fn)-1);π efn:=copy(fn,pos('.',fn)+1,length(fn));π endπ ELSEπ whole:=true;π repeatπ Inc(idx);π if not ExistFile(sfn+'.'+Merge(efn, idx)) then rend:=true;π until (idx=max) or Rend;ππ if (idx=max) and (rend=false) then { Nope? Okay, no problem. }π beginπ Assign(f,sfn+'.'+Merge(efn, max)); { Rename all oldies and make }π Erase(f); { room for it as number 1 }π for idx:=(max-1) downto 1 doπ beginπ Assign(f,sfn+'.'+Merge(efn, idx));π Rename(f,sfn+'.'+Merge(efn, idx+1));π end;π rn:=1;π end;ππ if rend then rn:=idx;ππ Assign(f,fn); { Rename the requested file! }π Rename(f,sfn+'.'+Merge(efn, rn));πend;ππType FileIDType = (fEXE, fZIP, fARJ, fLHA, fGIF87);ππfunction FileType(Filename : string) : FileIDType;π{ This function attempts to identify what type of a file Filename is }πvar Infile : file;π IdBytes : Array[1..10] of char;π SubId : string;πbeginπ FileType := fUnknown;π If NOT ExistFile(FileName) then Exit;π Assign(Infile, FileName);π Reset(Infile, 1);π If (FileSize(Infile) = 0) thenπ beginπ Close(Infile);π Exit;π end;π BlockRead(Infile, IDBytes, 10);π Close(Infile);π SubId := Copy(IDBytes, 1, 2);π If (SubID = 'MZ') then FileType := fEXEπ ELSEπ If (SubID = 'PK') then FileType := fZIPπ ELSEπ if (SubID = #96 + #234) then FileType := fARJπ ELSEπ If (Copy(IDBytes, 3, 5) = '-lh5-') then FileType := fLHAπ ELSEπ If (Copy(IDBytes, 3, 5) = '-lh1-') then FileType := fLHAπ ELSEπ if (Copy(IDbytes, 1, 5) = 'GIF89a') then FileType := fGIF87;πend;ππfunction FileExistWild(Mask : string) : boolean; { Does X*.* exist? :) }πvar sr : SearchRec;πbeginπ FindFirst(Mask, AnyFile, SR);π If DosError<>18 thenπ FileExistWild := TRUEπ ELSEπ FileExistWild := FALSE;πend;ππFunction SizeFile(Fname : string) : longint;πvar sr : SearchRec;π idx : integer;πbeginπ SizeFile := 0;π Findfirst(Fname, Anyfile, SR);π If DosError = 0 then SizeFile := SR.Size ELSE SizeFile := -1;πend;ππfunction SwtVal(Swt : string) : string;π{ Returns the value of a command line switch. Eg: for /COM:2, callπ SwtVal('/COM2:') and it will return 2. }πvar ndx, found : byte;π st : string;πbeginπ Found := 0;π For ndx := 1 to ParamCount doπ beginπ if StUpCase(copy(paramstr(ndx), 1, length(swt))) = StUpCase(swt) thenπ beginπ Found := ndx;π Break;π end;π end;π if (Found = 0) thenπ beginπ swtval := '';π Exit;π end;π st := '';π st := StUpCase(Copy(ParamStr(Found), Length(Swt) + 1,π Length(ParamStr(Found)) - Length(Swt)));π For ndx := 1 to Length(St) doπ if (St[ndx] = '_') then St[ndx] := #32;π SwtVal := st;πend;ππFunction StatusBar(total, amt : longint) : string;πConst BarLength = 40;πvar a, b, c, d : longint;π percent : real;π st : string;πbeginπ If (total = 0) OR (amt = 0) thenπ beginπ StatusBar := '';π Exit;π end;π if (Amt > Total) then amt := total;π Percent := Amt / Total * (Barlength * 10);π a := trunc(percent);π b := a div 10;π c := 1;π percent := amt / total * 100;π d := trunc(percent);π st := ' (' + int_to_str(d) + '%)';π StatusBar := CharStr(b * c, #219) + CharStr(Barlength - (b * c), #176) + st;πend;ππfunction EraseFiles(Path, Mask : string) : integer;πvar S : SearchRec;πbeginπ FindFirst(Path + Mask, Anyfile - Directory, s); { Find the first file }π If (DosError = 18) then exit; { No files to erase }π KillFile(Path + s.name); { Erase the first file }π repeatπ Findnext(s); { Find the next file }π If NOT (DOSError=18) then KillFile(Path + s.name); { Erase the file }π until Doserror=18; { no more files }π EraseFiles := IOResult; { Return the IO result }πend;π 4 05-25-9408:15ALL RODNEY JOHNSON hall of fame - my try SWAG9405 38 èo πUnit HighScr;πInterfaceπProcedure HS_Init(iNum: byte; ifn: string; icode: byte);π{Initializes the highscore manager}π{ iNum: byte - The number of scores to keep track of. Setting iNum to 0}π{ makes the program use however many scores it finds in the}π{ list file}π{ ifn: string - The filename of the list file. If the file exists, it isπ opened; otherwise, a new file is created. If iNum if set toπ more names than are in ifn, extra spaces are left blank. Ifπ ifn has too many, the extras are ignored.π NOTE: do not make inum=0 if you are creating a new listπ file}π{ icode: byte - encoding number, where 0=no encoding. The higher theπ number, the less recognizable the output file}ππFunction HS_CheckScore(score: longint): boolean;π{Checks to see if a score would make the highscore list}π{ score: longint - the score to check}π{Returns TRUE if the score made the list}ππFunction HS_NewScore(name: string; score: longint): boolean;π{Adds a new score to the list if it belongs}π{ name: string - the name of the player}π{ score: longint - the player's score}π{Returns TRUE if the score made the list}ππProcedure HS_Clear;π{Clears the highscore list, setting all names to dashes, all scores to 0}ππFunction HS_Name(i: byte): string;π{Returns the name from the Ith place of the list}π{ i: byte - the rank to check}ππFunction HS_Score(i: byte): longint;π{Returns the score from the Ith place of the list}π{ i: byte - the rank to check}ππProcedure HS_Done;π{Disposes of the highscore manager and saves the highscore list}ππImplementationπUsesπ Dos;πTypeπ PHSItem = ^THSItem;π THSItem = recordπ name: string[25];π score: longint;π end;π PHSItemList = ^THSItemList;π THSItemList = array[1..100] of THSItem;πVarπ numitems, code: byte;π item: PHSItemList;π fn: string[50];πProcedure FlipBit(var Buf; len, code: byte);πTypeπ TBuf = array[0..255] of byte;πvarπ i: byte;πbeginπ for i:=0 to len-1 doπ TBuf(Buf)[i]:=TBuf(Buf)[i] XOR Code;πend;πFunction GetStr(var f: file): string;πvarπ s: string;πbeginπ BlockRead(f, s[0], 1);π BlockRead(f, s[1], ord(s[0]));π GetStr:=s;πend;πFunction Exist(fn: string): boolean;πVarπ SRec: SearchRec;πBeginπ FindFirst(fn, $3F, SRec);π If DosError>0 then Exist:=False else Exist:=True;πEnd;πProcedure HS_Init(iNum: byte; ifn: string; icode: byte);πvarπ f: file;π i, found: byte;πbeginπ fn:=ifn;π code:=icode;π numitems:=iNum;π GetMem(item, 30*numitems);π HS_Clear;π if exist(fn) thenπ beginπ Assign(f, fn);π Reset(f, 1);π BlockRead(f, found, 1);π if numitems=0 then numitems:=found;π if found>numitems then found:=numitems;π for i:=1 to found doπ beginπ item^[i].name:=GetStr(f);π FlipBit(item^[i].name[1], ord(item^[i].name[0]), code);π BlockRead(f, item^[i].score, 4);π FlipBit(item^[i].score, 4, code);π end;π end;π if numitems=0 then numitems:=1;πend;πFunction HS_CheckScore(score: longint): boolean;πbeginπ if score>item^[numitems].score then HS_CheckScore:=TRUE else HS_CheckScore:=FALSE;πend;πFunction HS_NewScore(name: string; score: longint): boolean;πvarπ i, j: byte;π on: boolean;πbeginπ HS_NewScore:=FALSE;π for i:=1 to numitems doπ if score>item^[i].score thenπ beginπ for j:=numitems downto i+1 doπ item^[j]:=item^[j-1];π item^[i].name:=name;π item^[i].score:=score;π score:=0;π i:=numitems;π HS_NewScore:=TRUE;π end;πend;πProcedure HS_Clear;πvarπ i: byte;πbeginπ for i:=1 to numitems doπ beginπ item^[i].name:='-------------------------';π item^[i].score:=0;π end;πend;πFunction HS_Name(i: byte): string;πbeginπ HS_Name:=item^[i].name;πend;πFunction HS_Score(i: byte): longint;πbeginπ HS_Score:=item^[i].score;πend;πProcedure HS_Done;πvarπ f: file;π i: byte;πbeginπ Assign(f, fn);π Rewrite(f, 1);π BlockWrite(f, numitems, 1);π for i:=1 to numitems doπ beginπ FlipBit(item^[i].name[1], ord(item^[i].name[0]), code);π BlockWrite(f, item^[i].name, ord(item^[i].name[0])+1);π FlipBit(item^[i].score, 4, code);π BlockWrite(f, item^[i].score, 4);π end;π FreeMem(item, 30*numitems);πend;πEnd.π 5 05-25-9408:21ALL LARS P. FRIEND Registration Key Routine SWAG9405 10 èo {π* In a message originally to All, Brad Larned said:πBL >Hello All!ππBL >Does anyone have a good registration key routine, they wouldπBL >be willing toπBL >share, I can download Net-Mail or a response in this messageπBL >base will be fine..ππHere goes.... }ππtype regpass:array[1..23] of byte;ππfunction checkregister:boolean;πvarπ f:file of regpass;π p:regpass;π a,x,y,z,c:word;πbeginπ assign(f,'REGISTER.KEY');π reset(f);π read(f,p);π close(f);πππ for a:=1 to 20 doπ beginπ z:=z+p[a];π x:=x XOR p[a];π y:=y+NOT(p[a]);π end;π c:=z;π z:=z MOD 256;π x:=x MOD 256;π y:=y MOD 256;π checkregister:=false;ππ if ((x=p[21]) AND (y=p[22])) AND (z=p[23]) then checkregister:=true;π if c=0 then checkregister:=false;ππend;ππThis routine allows you to have both somebody's name and a checksum stored. πIf they don't match up, it appears that it isn't a registered copy. You can πstash whatever in the first 20 bytes, and the last three are reserved for a πchacksum. This is the routine that I use, and it seems to be pretty πmuck-proof;ππYou can write the routine to create the file and do the checksums yourself.πIt's idioticly simple. C-ya...π 6 05-26-9406:19ALL MATT SOTTILE PASCAL PASSWORD SWAG9405 13 èo {πThe example that changes color and echos '*'s is nice, but does it compensateπfor delete/backspace/enter keypresses?ππThe one I posted was intended when I wrote it to be a UNIX like passwordπinput, where the cursor just sits there and doesn't react.ππDoes anyone want a simple password entry/encryption unit?ππ(I'll give it to you anyways.. ) :)ππ--CUT HERE-- }πunit crypt;π{AmoebOS v1.0 - Password/Cryyptography unit}ππ{Simple password entry and encryption routines}π{(C)1994 Matt Sottile/RAMSoft! Freeware}π{Please notify the author if you use or modify this unit in any way}π{Internet mail : matts@caeser.geog.pdx.edu or matts@psg.com}π{ ramsoft@industrial.com}ππinterfaceππfunction noecho(pmt : string) : string;πfunction pwcrypt(op : string) : string;ππimplementationππuses Crt, Dos;ππfunction noecho(pmt : string) : string;πvarπ ch : char;π d : boolean;π temp, st : string;πbeginπ write(pmt);π d := false;π temp := '';π st := '';π repeatπ temp := st;π repeat until keypressed;π ch := readkey;π if (ch = chr(8)) then st := temp;π if (ch = chr(13)) then d := true;π if not ((ch = chr(8)) and (ch = chr(13))) then st := st+ch; π until d = true;π noecho := temp;π writeln;πend;ππfunction pwcrypt(op : string) : string;πvarπ ptr : integer;π ip : string;πbeginπ ip := '';π ptr := 1;π repeatπ ip := ip+chr(((ord(op[ptr])+ord(op[length(op)-ptr]) xor length(op))));π ip[ptr] := chr(ord(ip[ptr])+2);π inc(ptr);π until ptr = length(op)+1;π pwcrypt := ip;πend;ππbeginπend.ππ 7 05-26-9406:19ALL JAMIE RUTHERFORD Scrolling or page down SWAG9405 10 èo πfunction More: string;πvarπ Prompt: char;πbeginπ More:='';π if Pause and (Lines=mem[$40:$84]) thenπ beginπ write('Continue - [Y]es, [N]o? ');π Prompt:=ReadKey;π writeln(upcase(Prompt));π if Prompt in ['N','n'] thenπ halt(0)π Lines:=0π end;π inc(Lines)πend; {More}ππPause and Lines are both global variables. Since I call the functionπfrom many other functions/procedures I decided it would be less workπthen passing them through. Pause is simple a flag deciding whether orπnot you want pausing or not. You may not want to take the same action Iπdid when the user doesn't want to continue. The mem command looks atπmemory location 0040:0084 which contains the number of lines on theπscreen. This prevents the need to check what mode the screen is in.ππAnyways, the way I used it is as follows:ππwriteln(More,'What ever you may want to display');ππSince functions are executed first, it determines wheter or not toπdisplay the line or prompt to continue.ππHope that helps... (assuming you can figure out my explanations)π 8 05-26-9410:52ALL RICHARD ODOM Amortization Routine SWAG9405 32 èo program amort;ππ{ This program does a good job of loan amortization. The originalπ author is unknown. I added a procedure to exit the program withoutπ showing all years for amortization. Richard Odom..VA Beach }ππconstπ MonthTab = 8; {month column}π PayTab = 14; {payment column}π PrinTab = 28; {principle column}π IntTab = 41; {interest column}π BalTab = 53; {balance column}πππvarπ balance, payment, interest, rate, years,π i1, i2, CurrInt, CurrPrin, ypay, yint, yprin,π GTPay, GTInt, GTPrin: real;π year, month, line: integer;π borrower: string[32];π response: char;πππππbeginπ repeatππ ClrScr;π write ('Name of borrower: ');π readln (borrower);π write ('Amount of loan: ');π readln (balance);π write ('Interest rate: ');π readln (interest);π i1 := interest/1200 {monthly interest};π write ('Do you know the monthly payments? ');π readln (response);ππ if UpCase(response) = 'Y'π then beginπ write ('Payment amount: ');π readln (payment);π endπ else beginπ write ('Number of years: ');π readln (years);π i2 := exp(ln(i1 + 1) * (12 * years));π payment := balance * i1 * i2 / (i2 - 1);π payment := int(payment * 100 + 0.5) / 100;π writeln ('The monthly payment is $',payment:4:2,'.')π end;ππ write ('Starting year for loan: ');π readln (year);π write ('Starting month for loan: ');π readln (month);π write ('Press <RETURN> to see monthly totals.');π readln (response);π ClrScr; line := 6;π writeln ('Loan for ',borrower);π writeln (' Loan of $',balance:4:2,' at ',interest:4:2,'% interest.');π writeln (' Fixed monthly payments of $',payment:4:2,'.');π writeln;π writeln (year:4,' Month Payment Principle Interest Balance');π ypay := 0; yprin := 0; yint := 0;π GTPay := 0; GTInt := 0; GTPrin := 0; {initialize totals}ππ while balance>0 do beginπ CurrInt := int(100 * i1 * balance +0.5) / 100;π CurrPrin := payment - CurrInt;ππ if CurrPrin>balance then beginπ CurrPrin := balance;π payment := CurrInt + CurrPrin;π end;ππ balance := balance - CurrPrin;π ypay := ypay + payment; yint := yint + CurrInt; yprin := yprin + CurrPrin;π GTPay := GTPay + payment; GTInt := GTInt + CurrInt; GTPrin := GTPrin + CurrPrin;π line := line + 1; GotoXY(MonthTab,line);π write (month:2); GotoXY(PayTab,line);π write (payment:10:2); GotoXY(PrinTab,line);π write (CurrPrin:10:2); GotoXY(IntTab,line);π write (CurrInt:10:2); GotoXY(BalTab,line);π writeln (balance:12:2);π month := month + 1;ππ if (month>12) or (balance=0.0) then beginπ writeln; line := line + 2;π write (year:4,' Total'); GotoXY(PayTab,line);π write (ypay:10:2); GotoXY(PrinTab,line);π write (yprin:10:2); GotoXY(IntTab,line);π write (yint:10:2); GotoXY(BalTab,line);π writeln (balance:12:2);π year := year + 1;π month := 1;π ypay := 0; yprin := 0; yint := 0;ππ if balance>0 then beginπ writeln;π writeln ('Press <RETURN> to see ',year:4,'.');π write('Enter Q to end program ');π readln (response);π If upcase(response)='Q' thenπ halt;π ClrScr; line := 2; writeln (year:4,' Month Payment Principle Interest Balance');π end;ππ end;ππ end; {while}ππ writeln; line := line + 2;π write ('Grand Total'); GotoXY(PayTab,line);π write (GTPay:10:2); GotoXY(PrinTab,line);π write (GTPrin:10:2); GotoXY(IntTab,line);π write (GTInt:10:2); GotoXY(BalTab,line);π writeln (balance:12:2);π writeln;π write ('Do you wish to start over? ');π readln (response);ππ until UpCase(response)='N';ππend. 9 05-26-9411:04ALL SWAG SUPPORT TEAM General Library Routines SWAG9405 159 èo unit MiscLib;πinterfaceπuses crt,dos;ππconstπ MaxFiles = 30;π MaxChoices = 8;ππtypeπ STRING79 = string[79];π TOGGLE_REC = recordπ NUM_CHOICES: integer;π STRINGS : array [0..8] of STRING79;π LOCATIONS : array [0..8] of integer;π end;π RESPONSE_TYPE = (NO_RESPONSE, ARROW, KEYBOARD, RETURN);π MOVEMENT = (NONE, LEFT, RIGHT, UP, DOWN);π FnameType = string[12];π FileListType = array[1..MaxFiles] of FnameType;π ScrMenuRec = recordπ Selection : array[1..MaxChoices] of STRING79;π Descripts : array[1..MaxChoices,1..3] of STRING79;π end;π ScrMenuType = objectπ NumChoices : integer;π Last : integer;π Line, Col : integer;π MenuData : ScrMenuRec;π procedure Setup(MData: ScrMenuRec);π function GetChoice : integer;π end;πππprocedure Set_Video (ATTRIBUTE: integer);πprocedure Put_String (OUT_STRING: STRING79; LINE, COL, ATTRIB: integer);πprocedure Put_Text (OUT_STRING: STRING79; LINE, COL: integer);πprocedure Put_Colored_Text (OUT_STRING: STRING79;π LINE, COL, TXTCLR, BKGCLR: integer);πprocedure Put_Centered_String (OUT_STRING: STRING79; LINE, ATTRIB: integer);πprocedure Put_Centered_Text (OUT_STRING: STRING79; LINE: integer);πprocedure Put_Error (OUT_STRING: STRING79; LINE, COL: integer);πprocedure End_Erase (LINE, COL: integer);πprocedure Put_Prompt (OUT_STRING: STRING79; LINE, COL: integer);πprocedure Get_Response (var RESPONSE : RESPONSE_TYPE;π var DIRECTION : MOVEMENT;π var KEY_RESPONSE: char);πprocedure Get_String (var IN_STRING: STRING79;π LINE, COL, ATTRIB, STR_LENGTH: integer);πprocedure Get_Integer (var NUMBER: integer;π LINE, COL, ATTRIB, NUM_LENGTH: integer);πprocedure Get_Prompted_String (var IN_STRING: STRING79;π INATTR, STR_LENGTH: integer;π STRDESC: STRING79;π DESCLINE, DESCCOL: integer;π PROMPT: STRING79;π PRLINE, PRCOL: integer);πprocedure Put_1col_Toggle (TOGGLE: TOGGLE_REC; COL, CHOICE: integer);πprocedure Get_1col_Toggle ( TOGGLE: TOGGLE_REC;π COL: integer;π var CHOICE: integer;π PROMPT: STRING79;π PRLINE, PRCOL: integer);πprocedure Box_Text (TopX, TopY, BotX, BotY, BoxColor: integer);πprocedure Solid_Box (TopX, TopY, BotX, BotY, BoxColor: integer);πprocedure swap_fnames(var A,B: FnameType);πprocedure FileSort(var fname: FileListType; NumFiles: integer);πfunction Get_Files_Toggle (choices: FileListType;π NumChoices,NumRows,row,col:integer): FnameType;πfunction Get_File_Menu(mask: string;NumRows,Row,Col: integer): FnameType;πππ{-------------------------------------------------------------------------}πimplementationππprocedure Set_Video (ATTRIBUTE: integer);π{πNOTES:π The attribute code, based on bits, is as follows:π 0 - normal video 1 - reverse videoπ 2 - bold video 3 - reverse and boldπ 4 - blinking video 5 - reverse and blinkingπ 6 - bold and blinking 7 - reverse, bold, and blinkingπ}ππvarπ BLINKING,π BOLD: integer;ππbeginπ BLINKING := (ATTRIBUTE AND 4)*4;π if (ATTRIBUTE AND 1) = 1 thenπ beginπ BOLD := (ATTRIBUTE AND 2)*7;π Textcolor (1 + BLINKING + BOLD);π TextBackground (3);π endπ elseπ beginπ BOLD := (ATTRIBUTE AND 2)*5 DIV 2;π Textcolor (7 + BLINKING + BOLD);π TextBackground (0);π end;πend;ππ{-------------------------------------------------------------------------}ππprocedure Put_String (OUT_STRING: STRING79;π LINE, COL, ATTRIB: integer);ππbeginπ Set_Video (ATTRIB);π GotoXY (COL, LINE);π write (OUT_STRING);π Set_Video (0);πend;ππ{-------------------------------------------------------------------------}ππprocedure Put_Text (OUT_STRING: STRING79;π LINE, COL: integer);ππbeginπ GotoXY (COL, LINE);π write (OUT_STRING);πend;ππ{-------------------------------------------------------------------------}ππprocedure Put_Colored_Text (OUT_STRING: STRING79;π LINE, COL, TXTCLR, BKGCLR: integer);ππbeginπ GotoXY (COL, LINE);π TextColor (TXTCLR);π TextBackground (BKGCLR);π write (OUT_STRING);πend;ππ{-------------------------------------------------------------------------}ππprocedure Put_Centered_String (OUT_STRING: STRING79;π LINE, ATTRIB: integer);ππbeginπ Put_String (OUT_STRING, LINE, 40-Length(OUT_STRING) div 2, ATTRIB);πend;ππ{-------------------------------------------------------------------------}ππprocedure Put_Centered_Text (OUT_STRING: STRING79;π LINE: integer);ππbeginπ Put_Text (OUT_STRING, LINE, 40-Length(OUT_STRING) div 2);πend;ππ{-------------------------------------------------------------------------}ππprocedure Put_Error (OUT_STRING: STRING79;π LINE, COL: integer);ππvarπ ANY_CHAR : char;ππbeginπrepeatπ Put_String (OUT_STRING, LINE, COL, 6);πuntil keypressed = true;πend;ππ{-------------------------------------------------------------------------}ππprocedure End_Erase (LINE, COL: integer);ππbeginπ GotoXY (COL, LINE);π ClrEol;πend;ππ{-------------------------------------------------------------------------}ππprocedure Put_Prompt (OUT_STRING: STRING79;π LINE, COL: integer);ππbeginπ GotoXY (COL, LINE);π ClrEol;π Put_String (OUT_STRING, LINE, COL, 3);πend;ππ{-------------------------------------------------------------------------}πππprocedure Get_Response (var RESPONSE : RESPONSE_TYPE;π var DIRECTION : MOVEMENT;π var KEY_RESPONSE: char);ππconstπ BELL = 7;π CARRIAGE_RETURN = 13;π ESCAPE = 27;π RIGHT_ARROW = 77;π LEFT_ARROW = 75;π DOWN_ARROW = 80;π UP_ARROW = 72;ππvarπ IN_CHAR: char;ππbeginπ RESPONSE := NO_RESPONSE;π DIRECTION := NONE;π KEY_RESPONSE := ' ';π repeatπ IN_CHAR := ReadKey;π if IN_CHAR = #0 thenπ beginπ RESPONSE := ARROW;π IN_CHAR := ReadKey;π if Ord(IN_CHAR) = LEFT_ARROW thenπ DIRECTION := LEFTπ else if Ord(IN_CHAR) = RIGHT_ARROW thenπ DIRECTION := RIGHTπ else if Ord(IN_CHAR) = DOWN_ARROW thenπ DIRECTION := DOWNπ else if Ord(IN_CHAR) = UP_ARROW thenπ DIRECTION := UPπ elseπ beginπ RESPONSE := NO_RESPONSE;π write (Chr(BELL));π endπ endπ else if Ord(IN_CHAR) = CARRIAGE_RETURN thenπ RESPONSE := RETURNπ elseπ beginπ RESPONSE := KEYBOARD;π KEY_RESPONSE := UpCase (IN_CHAR);π end;π until RESPONSE <> NO_RESPONSE;πend;ππ{-------------------------------------------------------------------------}ππprocedure Get_String (var IN_STRING: STRING79;π LINE, COL, ATTRIB, STR_LENGTH: integer);ππvarπ OLDSTR : STRING79;π IN_CHAR: char;π I : integer;ππconstπ BELL = 7;π BACK_SPACE = 8;π CARRIAGE_RETURN = 13;π ESCAPE = 27;π RIGHT_ARROW = 77;ππbeginπ OLDSTR := IN_STRING;π Put_String (IN_STRING, LINE, COL, ATTRIB);π for I := Length(IN_STRING) to STR_LENGTH-1 doπ Put_String (' ', LINE, COL + I, ATTRIB);π GotoXY (COL, LINE);π IN_CHAR := ReadKey;π if Ord(IN_CHAR) <> CARRIAGE_RETURN thenπ IN_STRING := '';π while Ord(IN_CHAR) <> CARRIAGE_RETURN doπ beginπ if Ord(IN_CHAR) = BACK_SPACE thenπ beginπ if Length(IN_STRING) > 0 thenπ beginπ IN_STRING[0] := Chr(Length(IN_STRING)-1);π write (Chr(BACK_SPACE));π write (' ');π write (Chr(BACK_SPACE));π end;π end { if BACK_SPACE }π else if IN_CHAR = #0 thenπ beginπ IN_CHAR := ReadKey;π if Ord(IN_CHAR) = RIGHT_ARROW thenπ beginπ if Length(OLDSTR) > Length(IN_STRING) thenπ beginπ IN_STRING[0] := Chr(Length(IN_STRING) + 1);π IN_CHAR := OLDSTR[Ord(IN_STRING[0])];π IN_STRING[Ord(IN_STRING[0])] := IN_CHAR;π write (IN_CHAR);π endπ end { RIGHT_ARROW }π elseπ write (Chr(BELL));π end { IN_CHAR = #0 }π else if Length (IN_STRING) < STR_LENGTH thenπ beginπ IN_STRING[0] := Chr(Length(IN_STRING) + 1);π IN_STRING[Ord(IN_STRING[0])] := IN_CHAR;π TextColor (15);π TextBackGround (11);π write (IN_CHAR);π endπ elseπ write (Chr(BELL));π IN_CHAR := ReadKey;π end;π Put_String (IN_STRING, LINE, COL, ATTRIB);π for I := Length(IN_STRING) to STR_LENGTH - 1 doπ Put_String (' ', LINE, COL+I, ATTRIB);πend;ππ{-------------------------------------------------------------------------}ππprocedure Get_Integer (var NUMBER: integer;π LINE, COL, ATTRIB, NUM_LENGTH: integer);ππconstπ BELL = 7;ππvarπ VALCODE : integer;π ORIGINAL_STR,π TEMP_STR : STRING79;π TEMP_INT : integer;ππbeginπ Str (NUMBER:NUM_LENGTH, ORIGINAL_STR);π repeatπ TEMP_STR := ORIGINAL_STR;π Get_String (TEMP_STR, LINE, COL, ATTRIB, NUM_LENGTH);π while TEMP_STR[1] = ' ' doπ TEMP_STR := Copy (TEMP_STR, 2, Length (TEMP_STR));π Val (TEMP_STR, TEMP_INT, VALCODE);π if (VALCODE <> 0) thenπ write (Chr(BELL));π until VALCODE = 0;π NUMBER := TEMP_INT;π Str (NUMBER:NUM_LENGTH, TEMP_STR);π Put_String (TEMP_STR, LINE, COL, ATTRIB);πend;ππ{-------------------------------------------------------------------------}ππprocedure Get_Prompted_String (var IN_STRING: STRING79;π INATTR, STR_LENGTH: integer;π STRDESC: STRING79;π DESCLINE, DESCCOL: integer;π PROMPT: STRING79;π PRLINE, PRCOL: integer);ππbeginπ Put_String (STRDESC, DESCLINE, DESCCOL, 2);π Put_Prompt (PROMPT, PRLINE, PRCOL);π Get_String (IN_STRING, DESCLINE, DESCCOL + Length(STRDESC),π INATTR, STR_LENGTH);π Put_String (STRDESC, DESCLINE, DESCCOL, 0);πend;ππ{-------------------------------------------------------------------------}ππprocedure Put_1col_Toggle (TOGGLE: TOGGLE_REC;π COL, CHOICE: integer);ππvarπ I: integer;ππbeginπ with TOGGLE doπ beginπ Put_String (STRINGS[0], LOCATIONS[0], COL, 0);π for I := 1 to NUM_CHOICES doπ Put_String (STRINGS[I], LOCATIONS[I], COL, 0);π if (CHOICE <1) or (CHOICE > NUM_CHOICES) thenπ CHOICE := 1;π Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 1);π end;πend;ππ{-------------------------------------------------------------------------}ππprocedure Get_1col_Toggle ( TOGGLE: TOGGLE_REC;π COL: integer;π var CHOICE: integer;π PROMPT: STRING79;π PRLINE, PRCOL: integer);ππvarπ RESP : RESPONSE_TYPE;π DIR : MOVEMENT;π KEYCH: char;ππbeginπ Put_Colored_Text (PROMPT, PRLINE, PRCOL, 15, 0);π with TOGGLE doπ beginπ Put_String (STRINGS[0], LOCATIONS[0], COL, 2);π if (CHOICE < 1) or (CHOICE > NUM_CHOICES) thenπ CHOICE := 1;π Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 1);π RESP := NO_RESPONSE;π while RESP <> RETURN doπ beginπ Get_Response (RESP, DIR, KEYCH);π case RESP ofπ ARROW:π if DIR = UP thenπ beginπ Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 0);π if CHOICE = 1 thenπ CHOICE := NUM_CHOICESπ elseπ CHOICE := CHOICE - 1;π Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 1);π endπ else if DIR = DOWN thenπ beginπ Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 0);π if CHOICE = NUM_CHOICES thenπ CHOICE := 1π elseπ CHOICE := CHOICE + 1;π Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 1);π endπ elseπ write (Chr(7));π KEYBOARD: write (Chr(7));π RETURN: ;π end;π end; {while}π Put_String (STRINGS[0], LOCATIONS[0], COL, 0);π end;πend;ππ{-------------------------------------------------------------------------}ππprocedure Box_Text (TopX, TopY, BotX, BotY, BoxColor: integer);ππvarπ i : integer;π width : integer;π height: integer;ππbeginπ TextBackGround (BoxColor);π height := BotY - TopY;π width := BotX - TopX;π GotoXY (TopX, TopY);π for i := 1 to width doπ write (' ');π for i := TopY to (TopY+height) doπ beginπ GotoXY (TopX, i);π write (' ');π GotoXY (BotX-1, i);π write (' ');π end;π GotoXY (TopX, BotY);π for i := 1 to width doπ write (' ');πend;ππ{-------------------------------------------------------------------------}ππprocedure Solid_Box (TopX, TopY, BotX, BotY, BoxColor: integer);ππvarπ i : integer;π j : integer;π width : integer;ππbeginπ TextBackGround (BoxColor);π GotoXY (TopX, TopY);π width := BotX - TopX;π for i := TopY to BotY doπ beginπ for j := 1 to width doπ write (' ');π GotoXY (TopX, i);π end;πend;ππprocedure swap_fnames(var A,B: FnameType);πvarπ Temp : FnameType;πbeginπ Temp := A;π A := B;π B := Temp;πend;ππprocedure FileSort(var fname: FileListType;NumFiles: integer);πvarπ i,j : integer;πbeginπ for j := NumFiles downto 2 doπ for i := 1 to j-1 doπ if fname[i]>fname[j] thenπ swap_fnames(fname[i],fname[j]);πend;ππfunction Get_Files_Toggle (choices:FileListType;π NumChoices,NumRows,row,col:integer): FnameType;πvarπ i,r : integer;π Resp : Response_Type;π dir : movement;π keych : char;ππprocedure Put_Files_Toggle (choices: FileListType; First,NumRows,row,col: integer);πvarπ i : integer;πbeginπ for i := 0 to NumRows-1 doπ Put_string (choices[First+i],row+i,col,0);πend;ππprocedure Padnames;πvarπ i,p : integer;πbeginπ for i := 1 to MaxFiles doπ beginπ p := 12-length(choices[i]);π while p>0 doπ beginπ choices[i] := choices[i]+' ';π p := p-1;π end;π end;πend;ππbeginπ Padnames;π i := 1;π r := 1;π if NumChoices < NumRows thenπ NumRows := NumChoices;π Put_Files_Toggle (choices,1,NumRows,row,col);π Get_Files_Toggle := choices[i];π Put_string(choices[i],row,col,1);π resp := No_Response;π while resp <> Return doπ beginπ Get_response (resp,dir,keych);π case resp ofπ ARROW: if dir=UP thenπ beginπ Put_string(choices[i],row+r-1,col,0);π if i=1 thenπ beginπ i := NumChoices;π r := NumRows;π Put_Files_Toggle(choices,i+1-NumRows,NumRows,row,col);π endπ else if r=1 thenπ beginπ i := i-1;π Put_Files_Toggle(choices,i,NumRows,row,col);π endπ elseπ beginπ i := i-1;π r := r-1;π end;π Put_string(choices[i],row+r-1,col,1);π endπ else if dir=DOWN thenπ beginπ Put_string(choices[i],row+r-1,col,0);π if i=NumChoices thenπ beginπ i := 1;π r := 1;π Put_Files_Toggle(choices,i,NumRows,row,col);π endπ else if r=NumRows thenπ beginπ i := i+1;π Put_Files_Toggle(choices,i+1-NumRows,NumRows,row,col);π endπ elseπ beginπ i := i+1;π r := r+1;π end;π Put_string(choices[i],row+r-1,col,1);π endπ elseπ write (chr(7));π KEYBOARD: write (chr(7));π end; { case }π end;π Get_Files_toggle := choices[i];πend;ππfunction Get_File_Menu(mask: string;NumRows,Row,Col: integer): FnameType;πvarπ i : integer;π NumFiles : integer;π FileList : FileListType;π dirinfo : SearchRec;πbeginπ i := 1;π FindFirst(mask,Archive,dirinfo);π while (DosError=0) AND (i<MaxFiles+1) doπ beginπ FileList[i] := dirinfo.name;π FindNext(dirinfo);π i := i+1;π end;π NumFiles := i-1;π FileSort(FileList,NumFiles);π Get_File_Menu := Get_Files_Toggle(FileList,NumFiles,NumRows,Row,Col);πend;ππprocedure ScrMenuType.Setup(MData : ScrMenuRec);πvar i : integer;πbeginπ with MenuData doπ for i := 1 to MaxChoices doπ beginπ selection[i] := MData.selection[i];π Descripts[i,1] := MData.descripts[i,1];π Descripts[i,2] := MData.descripts[i,2];π Descripts[i,3] := MData.descripts[i,3];π end;πend;ππfunction ScrMenuType.GetChoice : integer;πvarπ i : integer;π Resp : Response_Type;π Dir : Movement;π KeyCh : char;ππprocedure PutDescripts;πvar i : integer;πbeginπ window(0,0,79,24);π Solid_Box(3,21,79,24,lightgray);π for i := 1 to 3 doπ Put_Colored_Text(MenuData.Descripts[last,i],20+i,4,white,lightgray);πend;ππbeginπwith MenuData doπbeginπ for i := 0 to NumChoices-1 doπ Put_String(Selection[i+1],Line+i,Col,0);π Put_String(Selection[Last],Line+Last-1,Col,1);π Resp := No_Response;π while Resp <> Return doπ beginπ PutDescripts;π Get_Response(Resp,Dir,KeyCh);π case Resp ofπ Arrow :π if Dir = Up thenπ beginπ Put_String(Selection[Last],Line+Last-1,Col,0);π if Last = 1 thenπ Last := NumChoicesπ elseπ Last := Last-1;π Put_String(Selection[Last],Line+Last-1,Col,1);π endπ else if Dir = Down thenπ beginπ Put_String(Selection[Last],Line+Last-1,Col,0);π if Last = NumChoices thenπ Last := 1π elseπ Last := Last+1;π Put_String(Selection[Last],Line+Last-1,Col,1);π end;π end;π end;πend;πend;π{ Initialization Area }πbeginπend.ππ{------------------------------------ TEST PROGRAM ------------------- }ππprogram testdir;π{ program attempts to read directory }π{ shows filenames as column }ππuses dos,crt,miscLib;ππvarπ Fchoice : FnameType;π i,n : integer;ππππ{ *************** MAIN PROGRAM *************** }ππbeginπ ClrScr;π Fchoice := Get_File_Menu('*.*',8,10,30);π Put_string(Fchoice,24,1,0);π ReadLn;πend.πππ{------------------------------------ TEST PROGRAM ------------------- }ππprogram TestMenu;πuses crt,MiscLib;ππconstπ ChoiceData : ScrMenuRec =π (selection : ('Choice 1','Choice 2','Choice 3','Choice 4','','','','');π Descripts : (('This is','No 1','The First Choice'),π ('Number 2','The Second Choice and default',''),π ('Number 3','Last Choice, for now...','Last Line'),π ('Number 4','An added Selection','How bout that?'),π ('','',''),π ('','',''),π ('','',''),π ('','','')));πvarπ ScrMenu : ScrMenuType;π Choice : integer;ππbeginπ TextColor(white);π TextBackGround(Blue);π ClrScr;π ScrMenu.NumChoices := 4;π ScrMenu.Last := 2;π ScrMenu.Line := 6;π ScrMenu.Col := 30;π ScrMenu.Setup(ChoiceData);π Choice := ScrMenu.GetChoice;π ReadLn;πend.
